perm filename C1P1J[CMP,SYS] blob
sn#156483 filedate 1975-04-28 generic text, type T, neo UTF8
(PROG (SEXPR IBASE)
(SETQ IBASE (ADD1 7))
LOOP (SETQ SEXPR (ERRSET (READ)))
(COND ((EQ SEXPR (QUOTE $EOF$)) (ERR)))
(COND ((MEMQ (CAAR SEXPR) (QUOTE (BEGINBLOCK ENDBLOCK))) (GO LOOP)))
(PRINT (EVAL (CAR SEXPR)))
(GO LOOP))
(BEGINBLOCK COMPILER)
(DECLARE
(SPECIAL LOCVARS COUNT UNDECVARS)
(SPECIAL CODESIZE CONSTSIZE LISTING INDEV OUTDEV)
(SPECIAL ACS PDL SPLDLST)
(SPECIAL LDLST PRGSPFLG PROGVARS MINDEPTH)
(SPECIAL FUNNAME SUBFUNS LASTOUT)
(SPECIAL GOLIST EXIT EXITN PRSSL VGO PVR)
(SPECIAL NACS PDLAC ALLACS INUM0 MSGDEV)
(SPECIAL VALUEAC GOTABAC FARGAC ARRAYAC)
(SPECIAL LINCNT PAGEWIDTH PAGEHEIGHT)
(SPECIAL GENFUNS UNDFUNS STARTTIME)
(SPECIAL *SP *TB *CR *LF *VT *FF *CO *PT)
(SPECIAL *LP *RP *SL *AM *AT *RO *COLON)
(SPECIAL IBASE BASE *NOPOINT)
(SPECIAL TRACELIST SHOWNAMES))
(BEGINBLOCK MACROS)
(DEFPROP DFUNC (LAMBDA (L) (LIST (Q DEFPROP)
(CAADR L)
(MCONS (Q LAMBDA) (CDADR L) (CDDR L))
(Q EXPR)))
MACRO)
(DEFPROP DOCDR
(LAMBDA (CALL) (LIST (Q SETQ) (CADR CALL) (LIST (Q CDR) (CADR CALL))))
MACRO)
(DEFPROP FLUSHDEF (LAMBDA (L) (CONS (Q FLUSHEXPR) (CDR L))) MACRO)
(DEFPROP GENFUNNAME (LAMBDA (L) (Q (MAKESYM FUNNAME (GENSYM)))) MACRO)
(DEFPROP GENTAG (LAMBDA (L) (Q (NEXTSYM (Q TAG)))) MACRO)
(DEFPROP GENVAL (LAMBDA (L) (Q (NEXTSYM (Q VAL)))) MACRO)
(DEFPROP GENVAR (LAMBDA (L) (Q (NEXTSYM (Q VAR)))) MACRO)
(DEFPROP GETPROP (LAMBDA (L) (CONS (Q GET) (CDR L))) MACRO)
(DEFPROP IFIF
(LAMBDA (L) (LIST (Q COND) (CDR L) (LIST T (CONS (Q NOT) (CDDR L)))))
MACRO)
(DEFPROP INCR
(LAMBDA (L) (LIST (Q SETQ) (CADR L) (LIST (Q ADD1) (CADR L))))
MACRO)
(DEFPROP INITTAG (LAMBDA (L) (Q (INITSYM (Q TAG)))) MACRO)
(DEFPROP INITVAL (LAMBDA (L) (Q (INITSYM (Q VAL)))) MACRO)
(DEFPROP INITVAR (LAMBDA (L) (Q (INITSYM (Q VAR)))) MACRO)
(DEFPROP MAPDEF
(LAMBDA (L)
(LIST (Q MAPCAR)
(SUBST (CADR L)
(Q IND)
(Q (FUNCTION
(LAMBDA (PAIR)
(PUTPROP (CAR PAIR) (CADR PAIR) (QUOTE IND))))))
(LIST (Q QUOTE) (CADDR L))))
MACRO)
(DEFPROP MCONS
(LAMBDA (L)
(COND ((NULL (CDDR L)) (CADR L))
(T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
MACRO)
(DEFPROP OUTINST (LAMBDA (INST) (CONS (Q OUTSTAT) (CDR INST))) MACRO)
(DEFPROP OUTPSOP (LAMBDA (PSOP) (CONS (Q OUTSTAT) (CDR PSOP))) MACRO)
(DEFPROP OUTTAG (LAMBDA (TAG) (CONS (Q OUTSTAT) (CDR TAG))) MACRO)
(DEFPROP PDLINDEX (LAMBDA (L) (Q (MINUS (ADD1 (PDLDEPTH))))) MACRO)
(DEFPROP PDLDEPTH (LAMBDA (L) (Q (LENGTH PDL))) MACRO)
(DEFPROP PROPTABLE (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
(DEFPROP PROPVAL (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO)
(DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)
(DEFPROP REPLACECAR (LAMBDA (L) (CONS (Q RPLACA) (CDR L))) MACRO)
(DEFPROP REPLACECDR (LAMBDA (L) (CONS (Q RPLACD) (CDR L))) MACRO)
(DEFPROP TAGP (LAMBDA (L) (CONS (Q ATOM) (CDR L))) MACRO)
(ENDBLOCK MACROS)
(BEGINBLOCK TOPLEVEL)
(DFUNC (ACTONEXPR XPR)
(PROG (ACTION)
(COND ((ATOM XPR) (GO FLUSH)))
(SETQ ACTION (GETGET (CAR XPR) (Q COMPEFFECT)))
(COND (ACTION ((CAR ACTION) XPR) (RETURN NIL)))
FLUSH(FLUSHEXPR XPR)
(RETURN NIL)))
(DFUNC (ACTONMACRO XPR) (ACTONEXPR ((GETPROP (CAR XPR) (Q MACRO)) XPR)))
(DFUNC (CF) (COMPFILE (GETPROP (QUOTE TRY) (Q FILE))))
(DEFPROP CMP
(LAMBDA (L)
(PROG2 (PUTPROP (CAAR L)
(MCONS (Q LAMBDA) (CDAR L) (CDR L))
(Q EXPR))
(EVAL (LIST (Q COMPILE) (CAAR L)))))
FEXPR)
(DEFPROP COMFILE
(LAMBDA (FILE) (PROG (CODESIZE CONSTSIZE)
(PUTPROP (Q TRY) FILE (Q FILE))
(SETQ CODESIZE (SETQ CONSTSIZE 0))
(RETURN (COMPFILE FILE))))
FEXPR)
(DFUNC (COMPDEF DEFIN)
(PROG (ACTION)
(COND ((NOT (EQUAL (LENGTH DEFIN) 4))
(DATAERR ARGNOERR-COMPDEF)))
(COND ((SETQ ACTION (SEEKPROP (CADDDR DEFIN) (Q DEFACTION)))
((PROPVAL ACTION) DEFIN)
(RETURN NIL)))
(FLUSHDEF DEFIN)
(RETURN NIL)))
(DFUNC (COMPFILE INFILE OUTFILE)
(PROG (UNDFUNS GENFUNS CODESIZE CONSTSIZE STARTTIME)
(CARRET)
(SETQ STARTTIME (TIME))
(SETQ CODESIZE (SETQ CONSTSIZE 0))
(DOFILE (FUNCTION COMPREADS) INFILE OUTFILE)
(TELLTALE (CADR INFILE))
(LINEF)))
(DFUNC (COMPFUNC FUNNAME FUNEXP FUNFLAG FUNTYPE)
(PROG (LOCVARS UNDECVARS
ACS PDL SPLDLST ~storage map
MINDEPTH ~can't pop PDL beyond this point
LDLST ~items waiting to be loaded as function args
PRGSPFLG ~can spec vars of PROG be with those of LAMBDA
PROGVARS ~local variables of a prog
LASTOUT ~one instruction output buffer
SPECFLAG ~are there special variables
SUBFUNS ~subsidiary functions generated
COUNT) ~number of variable reverences so far
(COND ((GREATERP (LENGTH (CADR FUNEXP)) NACS)
(BARF TOOMANYARGS-COMPFUNC)))
(REMPROP FUNNAME (Q *UNDEF))
(PUTPROP FUNNAME T FUNTYPE)
(SETQ COUNT 1) (INITTAG) (INITVAL) (INITVAR)
(SETQ ACS (LISTNILS NACS))
(SETQ ALLACS (SUB1 (LSH 1 NACS)))
(SETQ PDL NIL)
(SETQ MINDEPTH (PDLDEPTH))
(REMPROP (Q ARG) (Q CMP))
(PUTPROP (Q GO) (Q ERRGO) (Q CMP))
(PUTPROP (Q RETURN) (Q ERRRETURN) (Q CMP))
(CARRET)
(OUTPSOP (LIST (Q LAP) FUNNAME FUNFLAG))
(COND ((EQ FUNTYPE (Q *LSUBR))
(SETQ FUNEXP (MCONS (CAR FUNEXP)
(LIST (CADR FUNEXP))
(CDDR FUNEXP)))
(PUTPROP (Q ARG) (Q CMPARG) (Q CMP))
(OUTINST (QUOTE (JSP 3 *LCALL))))
((AND (EQ FUNTYPE (QUOTE *FSUBR)) (CDADR FUNEXP))
(OUTINST (QUOTE (PUSHJ P *AMAKE)))))
(SETQ SPECFLAG (LAMBDABIND (CADR FUNEXP)))
(COND ((NOT (EQ (CAADDR FUNEXP) (QUOTE PROG)))
(SETQ PRGSPFLG NIL)))
(LOADCOMP (CADDR FUNEXP) VALUEAC)
(EXITBUM SPECFLAG)
(OUTINST (OUTINST NIL))
(UNBINDVARS NIL)
(COND (LDLST (BARF LDLSTLEFT-COMPFUNC)))
(CARRET) (LINEF)
(COND ((NOT (NULL UNDECVARS))
(PRINTMSG (CONS (Q SPECIAL) (REVERSE UNDECVARS)))))
(COND (SHOWNAMES (PRINSTTY FUNNAME)))
(MAPC (FUNCTION ACTONEXPR) SUBFUNS)
(RETURN FUNNAME)))
(DEFPROP COMPILE
(LAMBDA (NAMES)
(PROG (GENFUNS UNDFUNS CODESIZE CONSTSIZE
SHOWNAMES DONE PROP NAME FLAG PLIST)
(SETQ CODESIZE (SETQ CONSTSIZE 0))
LOOP (COND ((NULL NAMES) (OUTC NIL T)
(RETURN (REVERSE DONE))))
(SETQ NAME (CAR NAMES))
(COND ((NOT (ATOM NAME)) (EVAL (CONS (Q OUTPUT) NAME))
(OUTC T NIL)))
(SETQ NAMES (CDR NAMES))
(SETQ PLIST (CDR NAME))
ILOOP(COND ((NULL PLIST) (GO LOOP)))
(SETQ FLAG (CAR PLIST))
(SETQ PLIST (CDR PLIST))
(SETQ PROP (SEEKPROP FLAG (Q DEFACTION)))
(COND ((NULL PROP) (GO ELOOP)))
(SETQ DONE (CONS (CONS NAME FLAG) DONE))
((PROPVAL PROP) (LIST (Q DEFPROP) NAME (CAR PLIST) FLAG))
ELOOP(SETQ PLIST (CDR PLIST))
(GO ILOOP)))
FEXPR)
(DEFPROP COMPL
(LAMBDA (FILES)
(PROG NIL
(SETQ MSGDEV
(COND (LISTING (EVAL (MCONS (Q OUTPUT) (Q LST) LISTING)))))
LOOP (COND ((NULL FILES)
(OUTC MSGDEV NIL)
(SETQ MSGDEV NIL)
(OUTC NIL T)
(RETURN NIL)))
(COND ((DEVP (CAR FILES)) (SETQ INDEV (CAR FILES))
(GO ELOOP)))
(COMPFILE (LIST INDEV (CAR FILES))
(LIST OUTDEV
(CONS (COND ((ATOM (CAR FILES)) (CAR FILES))
(T (CAAR FILES)))
(Q LAP))))
ELOOP(DOCDR FILES)
(GO LOOP)))
FEXPR)
(DFUNC (COMPREADS) (READLOOP (FUNCTION ACTONEXPR)))
(DFUNC (DEFEXPR DEF)
(PROG (NAME EXP)
(SETQ NAME (CADR DEF))
(SETQ EXP (CADDR DEF))
(COND ((ATOM EXP) (FLUSHDEF DEF))
((NOT (EQ (CAR EXP) (Q LAMBDA))) (DATAERR NONLAMBDA-DEFEXPR))
((AND (CADR EXP) (ATOM (CADR EXP)))
(COMPFUNC NAME EXP (Q LSUBR) (Q *LSUBR)))
(T (COMPFUNC NAME EXP (Q SUBR) (Q *SUBR))))))
(DFUNC (DEFFEXPR DEF) (COMPFUNC (CADR DEF) (CADDR DEF) (Q FSUBR) (Q *FSUBR)))
(DFUNC (DO*EXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *SUBR)))
(DFUNC (DO*FEXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *FSUBR)))
(DFUNC (DOACT XPR) ((GETPROP (CAR XPR) (Q COMPACTION)) XPR))
(DFUNC (DODE XPR) (DEFEXPR (LIST (Q DEFPROP)
(CADR XPR)
(LIST (Q LAMBDA) (CADDR XPR) (CADDDR XPR)))))
(DFUNC (DODECLARE XPR) (MAPC (FUNCTION EVAL) (CDR XPR)))
(DFUNC (DODF XPR) (DEFFEXPR (LIST (Q DEFPROP)
(CADR XPR)
(LIST (Q LAMBDA) (CADDR XPR) (CADDDR XPR)))))
(DFUNC (DOFILE DOREADS INFILE OUTFILE)
(PROG (LINCNT)
(SETQ LINCNT 0)
(EVAL (MCONS (Q INPUT) (Q INCHAN) INFILE))
(EVAL (MCONS (Q OUTPUT) (Q OUTCHAN) OUTFILE))
(INC (QUOTE INCHAN) NIL)
(OUTC (QUOTE OUTCHAN) NIL)
(DOREADS)
(OUTC NIL T)
(INC NIL T)))
(DFUNC (FLUSHEXPR EXPR) (PROGN (CARRET) (PRINTEXPR EXPR) (CARRET) (LINEF)))
(DFUNC (FLUSHLAP LC) (PRINTLAP (READLAP LC)))
(DFUNC (PRINSTTY MESSAGE) (PROG (CHAN LINCNT)
(SETQ CHAN (OUTC MSGDEV NIL))
(SETQ LINCNT 0)
(PRINS MESSAGE)
(OUTC CHAN NIL)))
(DFUNC (PRINTMSG MESSAGE)
(PROG (CHAN LINCNT)
(SETQ CHAN (OUTC MSGDEV NIL))
(SETQ LINCNT 0)
(PRINT MESSAGE)
(LINEF)
(OUTC CHAN NIL)))
(DFUNC (READLOOP ACTFUNC) (PROG (EXPR)
LOOP (SETQ EXPR (ERRSET (READ)))
(COND ((EQ EXPR (Q $EOF$)) (RETURN NIL)))
(ACTFUNC (CAR EXPR))
(GO LOOP)))
(DEFPROP SPECIAL (LAMBDA (X) (MAPCAR (FUNCTION MAKESPECIAL) X)) FEXPR)
(DFUNC (TELLTALE FILENAME)
(PROG (CHAN)
(SETQ CHAN (OUTC MSGDEV NIL))
(LINEF) (LINEF)
(PRINL (LIST FILENAME (Q COMPILED)))
(PRINL (LIST CODESIZE (Q WORDS)))
(PRINL (LIST CONSTSIZE (Q CONSTANTS)))
(PRINL (LIST (QUOTIENT (DIFFERENCE (TIME) STARTTIME) 1000.)
(Q SECONDS)))
(LINEF) (LINEF)
(PRINL (Q (UNDEFINED FUNCTIONS)))
(LINEF)
(MAPC (FUNCTION (LAMBDA (X)
(COND ((GET X (Q *UNDEF)) (PRINS X)))))
UNDFUNS)
(LINEF) (LINEF)
(PRINL (Q (GENERATED FUNCTIONS)))
(LINEF)
(PRINL GENFUNS)
(LINEF) (LINEF)
(OUTC CHAN NIL)))
(DEFPROP UNSPECIAL (LAMBDA (X) (MAPCAR (FUNCTION MAKEUNSPECIAL) X)) FEXPR)
(MAPDEF COMPEFFECT
((COMPACTION DOACT) (MACRO ACTONMACRO)))
(MAPDEF COMPACTION
((DE DODE)
(DECLARE DODECLARE)
(DF DODF)
(DM EVAL)
(DEFPROP COMPDEF)
(LAP FLUSHLAP)
(SPECIAL EVAL)
(UNSPECIAL EVAL)))
(MAPDEF DEFACTION
((EXPR DEFEXPR) (FEXPR DEFFEXPR) (MACRO EVAL) (SPECIAL EVAL)
(DEFACTION EVAL) (*EXPR DO*EXPR) (*FEXPR DO*FEXPR)))
(SETQ LISTING NIL)
(SETQ MSGDEV NIL)
(SETQ OUTDEV (SETQ INDEV (READLIST (APPEND (EXPLODE (QUOTE DSK))
(LIST (ASCII 72))))))
(ENDBLOCK TOPLEVEL)
(BEGINBLOCK COMPILE)
(DFUNC (ACEFFECTS FN)
(COND ((SETQ FN (SEEKPROP FN (Q ACS))) (PROPVAL FN))
(T ALLACS)))
(DFUNC (ACNUMP X) (AND (NUMBERP X) (GREATERP X 0) (LESSP X (ADD1 NACS))))
(DFUNC (BINDVARS VARS INLAM)
(PROG (TEM VAR ACNO SPFLG1)
(COND ((AND VARS (ATOM VARS)) (DATAERR ATOMVARLIST-BINDVARS)))
(SETQ ACNO 1)
LOOP (COND ((NULL VARS) (RETURN SPFLG1)))
(SETQ TEM (SETQ VAR (CAR VARS)))
(COND ((NOT (VARIABLEP VAR)) (DATAERR NOTVAR-BINDVARS)))
(COND ((SPECIALP VAR) (GO SPECV)))
(COND ((ASSOC VAR LOCVARS) (SETQ VAR (GENVAR))))
(SETQ LOCVARS (CONS (CONS TEM VAR) LOCVARS))
(COND ((NOT (GETGET VAR (Q FTYPE))) (PUTPROP VAR T (Q FUNVAR))))
ELOOP(COND (INLAM (SETSLOT ACNO (LIST VAR))))
(SETQ ACNO (ADD1 ACNO))
(SETQ VARS (CDR VARS))
(GO LOOP)
SPECV(COND ((NOT PRGSPFLG) (SETQ PRGSPFLG (SETQ SPFLG1 T))
(OUTINST (Q (JSP 6 SPECBIND)))))
(OUTINST (LIST 0 (COND (INLAM ACNO) (T 0)) (LIST (Q SPECIAL) VAR)))
(GO ELOOP)))
(DFUNC (BOOLAND EXP VALAC TAG FLAG)
(PROGN (BOOL2 (CDR EXP) VALAC TAG T FLAG) (SETQ COUNT (PLUS 2 COUNT))))
(DFUNC (BOOLEQ EXP VALAC TAG FLAG)
(PROGN
(BOOLEQ1 (CDR EXP) VALAC TAG FLAG)
(OUTJRST TAG)))
(DFUNC (BOOLEQ1 EXP VALAC TAG F)
(PROG (ARG1 ARG2 ARG1LOC ARG2LOC AC MEM)
(COND ((NOT (EQ (LENGTH EXP) 2)) (BARF ARGNOERR-BOOLEQ)))
(SETQ ARG1 (COMPEXPR (CAR EXP) (FREEAC)))
(SETQ ARG2 (COMPEXPR (CADR EXP) (FREEAC)))
(SETQ ARG2LOC (ILOC1 ARG2 (FREEAC)))
(SETQ ARG1LOC (ILOC1 ARG1 (FREEAC)))
(COND ((ACNUMP ARG1LOC) (SETQ AC ARG1LOC)
(REMOVE ARG1)
(COND ((ACNUMP ARG2LOC) (REMOVE ARG2)))
(RST TAG)
(SETQ MEM (LOC ARG2))
(GO A))
((ACNUMP ARG2LOC) (REMOVE ARG2) (SETQ AC ARG2LOC) (RST TAG) (SETQ MEM (LOC ARG1)) (GO A)))
(LOADARG ARG1 (SETQ AC (FREEAC)))
(RST TAG)
(SETQ MEM (LOC ARG2))
(GO B)
A (REMOVE ARG1)
B (REMOVE ARG2)
(SAVEACS)
(OUT1 (COND (F (QUOTE CAMN)) (T (QUOTE CAME))) AC MEM)))
(DFUNC (COMPPRED EXP VALAC TAG FLAG MINDEPTH)
(PROG (TEM)
(COND ((CONSTANTP EXP) (SETQ EXP (LIST (Q QUOTE) EXP))))
(COND ((ATOM EXP) (GO ELSE)))
MACRO(COND ((SETQ TEM (GETL (CAR EXP) (Q (MACRO INMACRO))))
(SETQ EXP ((CADR TEM) EXP)) (GO MACRO)))
(COND ((SETQ TEM (SEEKPROP (CAR EXP) (Q BOOL)))
(RETURN ((PROPVAL TEM) EXP VALAC TAG FLAG))))
ELSE (SETQ EXP (PUTINAC (COMPEXPR EXP VALAC) (COND (VALAC) ((FREEAC)))))
(OUTCJMP FLAG EXP TAG)
(COND (FLAG (SETSLOT EXP (Q (QUOTE NIL)))))))
(DFUNC (BOOL2 EXP VALAC TAG F1 F2)
(PROG (G)
(CLRSPLD)
(SAVEACS)
(CLRPVARS)
(PUTPROP (SETQ G (GENTAG)) (TOPCOPY PDL) (QUOTE LEVEL))
A (COND ((NULL EXP) (COND (F2 (OUTJRST TAG))) (GO C)))
(COND ((AND F2 (NULL (CDR EXP))) (GO B)))
(COMPPRED (CAR EXP) VALAC (COND (F2 G) (T TAG)) (NOT F1) MINDEPTH)
(SETQ EXP (CDR EXP))
(GO A)
B (COMPPRED (CAR EXP) VALAC TAG F1 MINDEPTH)
(OUTENDTAG G)
C (CLRSPLD)
(CLEARACS)))
(DFUNC (BOOLNULL EXP VALAC TAG FLAG)
(COMPPRED (CADR EXP) VALAC TAG (NOT FLAG) MINDEPTH))
(DFUNC (BOOLOR EXP VALAC TAG FLAG)
(PROGN
(BOOL2 (CDR EXP) VALAC TAG NIL (NOT FLAG))
(SETQ COUNT (PLUS 2 COUNT))))
(DFUNC (BOOLQUOTE EXP VALAC TAG FLAG)
(BOOL2 NIL VALAC TAG NIL (IFIF FLAG (CADR EXP))))
(DFUNC (BOOLVALUE XPR VALAC EFFECTS TAG)
(PROGN
(COND ((NOT EFFECTS) (OUT1 (QUOTE TDZA) VALAC VALAC)))
(OUTENDTAG TAG)
(COND ((NOT EFFECTS)
(OUT1 (QUOTE MOVEI) VALAC (QUOTE (QUOTE T)))))
(VALLOC XPR VALAC EFFECTS)))
(DFUNC (CALLCMP XPR VALAC EFFECTS)
((GETPROP (CAR XPR) (Q CMP)) XPR VALAC EFFECTS))
(DFUNC (CALLCOMMU XPR VALAC EFFECTS)
(PROG (FUN ARGS TEM)
(SETQ FUN (CAR XPR))
(SETQ ARGS (COMPARGS (CDR XPR)))
(COND ((AND (SETQ TEM (SEEKPROP FUN (Q COMMU)))
(EQ (ILOC (CAR ARGS) VALUEAC) VALUEAC))
(SETQ ARGS (REVERSE ARGS))
(SETQ FUN (PROPVAL TEM))))
(LOADSUBRARGS ARGS)
(PROTECTACS (ACEFFECTS FUN))
(SETQ TEM (VALLOC XPR VALUEAC EFFECTS))
(OUTCALL (LENGTH ARGS) FUN)
(RETURN TEM)))
(DFUNC (CALLFSUBR XPR VALAC EFFECTS)
(PROG (TEM)
(LOADARG (LIST (Q QUOTE) (CDR XPR)) FARGAC)
(CLRSPLD)
(PROTECTACS (ACEFFECTS (CAR XPR)))
(SETQ TEM (VALLOC XPR VALUEAC EFFECTS))
(OUTCALL 17 (CAR XPR))
(RETURN TEM)))
(DFUNC (CALLFUNARGS XPR VALAC EFFECTS)
(PROG (ARGS FUN TEM)
(SETQ ARGS (COMPARGS (CDR XPR)))
(LOC (SETQ FUN (COMPEXPR (CAR XPR) VALAC)))
(LOADSUBRARGS ARGS)
(CLRSPLD)
(CLEARACS)
(REMOVE FUN)
(SETQ TEM (VALLOC XPR VALUEAC EFFECTS))
(OUTCALLF (LENGTH ARGS) (LOC FUN))
(RETURN TEM)))
(DFUNC (CALLLSUBR XPR VALAC EFFECTS)
(PROG (ARGS NARGS HOME INST RETTAG TEM)
(SETQ ARGS (CDR XPR))
(SETQ NARGS (LENGTH ARGS))
(CLRSPLD)
(SAVEACS)
(CLRPVARS)
(SLOTPUSH (Q (NIL . TAKEN)))
(OUTPUSH (GENCONST 0 0 (SETQ RETTAG (GENTAG)) 0 0))
LOOP (COND ((NULL ARGS) (GO CALL)))
(SETQ HOME (TOPCOPY PDL))
(SETQ INST (COMPEXPR (CAR ARGS) VALAC))
(RESTORE HOME)
(SETQ TEM (LOC INST))
(SLOTPUSH (Q (NIL . TAKEN)))
(OUTPUSH TEM)
(REMOVE INST)
(SETQ ARGS (CDR ARGS))
(GO LOOP)
CALL (SETQ TEM (PDLDEPTH))
(SAVEACS)
(COND ((NOT (EQ (PDLDEPTH) TEM)) (BARF PDLTOOLONG-LSUBRCALL)))
(OUTINST (LIST (Q MOVNI) 6 NARGS))
LLOOP(SLOTPOP)
(COND ((ZEROP NARGS) (GO CALL1)))
(SETQ NARGS (SUB1 NARGS))
(GO LLOOP)
CALL1(CLRSPLD)
(CLEARACS)
(SETQ TEM (VALLOC XPR VALUEAC EFFECTS))
(OUTJCALL 16 (CAR XPR))
(OUTTAG RETTAG)
(RETURN TEM)))
(DFUNC (CALLSUBR XPR VALAC EFFECTS)
(PROG (ARGS TEM)
(SETQ ARGS (COMPARGS (CDR XPR)))
(LOADSUBRARGS ARGS)
(COND ((SIDEEFFECTS (CAR XPR)) (CLRSPLD)))
(PROTECTACS (ACEFFECTS (CAR XPR)))
(SETQ TEM (VALLOC XPR VALUEAC EFFECTS))
(OUTCALL (LENGTH ARGS) (CAR XPR))
(RETURN TEM)))
(DFUNC (CLEARACS) (PUSHACS ALLACS T))
(DFUNC (CLRPVARS)
(PROG NIL
(COND ((NULL PROGVARS) (RETURN NIL)))
LOOP (COND ((NULL PROGVARS) (SETQ PRSSL (TOPCOPY PDL))
(SETQ MINDEPTH (PDLDEPTH))
(RETURN NIL))
((NOT (ILOC (CONS (CAR PROGVARS) COUNT) NIL))
(INITNIL (CAR PROGVARS))))
(DOCDR PROGVARS)
(GO LOOP)))
(DFUNC (CLRSPLD)
(PROG (LOC)
LOOP (COND ((NULL SPLDLST) (RETURN NIL)))
(SETQ LOC (ILOC (CAR SPLDLST) NIL))
(COND ((NOT (NUMBERP LOC)) (OUTSPECPUSH (CAAR SPLDLST)))
((ACNUMP LOC) (SLOTPUSH (SLOTCONT LOC))
(OUTPUSH LOC)))
(SETQ SPLDLST (CDR SPLDLST))
(GO LOOP)))
(DFUNC (CMP*EVAL XPR VALAC EFFECTS)
(PROG (TEM ARG FUN)
(SETQ ARG (CADR XPR))
(COND ((NOT (EQ (CAR ARG) (Q CONS))) (GO NOBUM)))
(SETQ FUN (CADR ARG))
MACRO(COND ((SETQ TEM (GETL (CAR FUN) (Q (MACRO INMACRO))))
(SETQ FUN ((CADR TEM) FUN)) (GO MACRO)))
(COND ((NOT (EQ (CAR FUN) (Q QUOTE))) (GO NOBUM)))
(SETQ TEM (CADR FUN))
(COND ((NOT (GETL TEM (Q (FEXPR FSUBR *FSUBR)))) (GO NOBUM)))
(LOADCOMP (CADDR ARG) FARGAC)
(PROTECTACS (ACEFFECTS TEM))
(OUTINST (LIST (Q CALL) 17 (LIST (Q E) TEM)))
(RETURN (VALLOC XPR VALUEAC EFFECTS))
NOBUM(RETURN (CALLSUBR XPR VALAC EFFECTS))))
(DFUNC (CMPARG XPR VALAC EFFECTS)
(PROG (ARG)
(SETQ ARG (COMPEXPR (CADR XPR) VALAC))
(COND ((EQ (CAR ARG) (QUOTE QUOTE))
(CPUSH VALAC)
(OUTMOVE VALAC (PDLINDEX))
(REMOVE ARG)
(OUTINST (LIST (QUOTE HRRZ) VALAC (CADR ARG) VALAC))
(RETURN (VALLOC XPR VALAC EFFECTS))))
(LOADARG ARG VALAC)
(OUT1 (QUOTE ADD) VALAC (PDLINDEX))
(OUTINST (LIST (QUOTE HRRZ) VALAC (MINUS INUM0) VALAC))
(RETURN (VALLOC XPR VALAC EFFECTS))))
(DFUNC (CMPBOOL XPR VALAC EFFECTS)
(PROG (G)
(PUTPROP (SETQ G (GENTAG)) T (QUOTE SET))
(COMPPRED XPR VALAC G T MINDEPTH)
OUT (RETURN (BOOLVALUE XPR VALAC EFFECTS G))))
(DFUNC (CMPCARCDR XPR VALAC EFFECTS)
(PROG (TEM)
(COND ((NOT (EQ (LENGTH XPR) 2)) (DATAERR ARGNOERR-CMPCARCDR)))
(COND (EFFECTS (RETURN (COMPSTAT (CADR XPR) VALAC))))
(PUTPROP (SETQ TEM (GENVAL))
(MCONS TEM (CAR XPR) (COMPEXPR (CADR XPR) VALAC))
(Q CHAIN))
(SETQ LDLST (CONS (SETQ TEM (LIST TEM)) LDLST))
(RETURN TEM)))
(DFUNC (CMPCOND XPR VALAC EFFECTS)
(PROG (TMPLDLST VARLOC)
(SETQ TMPLDLST LDLST)
LOOP (COND ((NULL TMPLDLST) (GO EXIT)))
(COND ((ASSOC (CAAR TMPLDLST) LOCVARS) (GO ISVAR)))
ELOOP(DOCDR TMPLDLST)
(GO LOOP)
EXIT (CLRSPLD) (SAVEACS) (CLRPVARS)
(CMPCOND1 (CDR XPR) VALAC EFFECTS MINDEPTH)
(SETQ COUNT (PLUS COUNT 2))
(RETURN (VALLOC XPR VALAC EFFECTS))
ISVAR(SETQ VARLOC (LOC (CONS (CAAR TMPLDLST) COUNT)))
(COND ((NOT (NUMBERP VARLOC)) (GO PUSH)))
(COND ((NOT (DVP (SLOTCONT VARLOC)))
(SETSLOT VARLOC (CONS (CAAR TMPLDLST) COUNT))
(GO LOOP)))
PUSH (SLOTPUSH (CONS (CAAR TMPLDLST) COUNT))
(OUTPUSH VARLOC)
(GO ELOOP)))
(DFUNC (CMPCOND1 EXP VALAC EFFECTS MINDEPTH)
(PROG (CONDEXIT PAIREXIT H1 H2 RETNIL IRSSL ACNIL PAIR AC)
(SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
(SETQ CONDEXIT (GENTAG))
(SETQ MINDEPTH (PDLDEPTH))
(PUTPROP CONDEXIT (SETQ IRSSL (TOPCOPY PDL)) (Q LEVEL))
LOOP (COND ((NULL EXP) (COND (RETNIL (LOADARG (Q (QUOTE NIL)) AC)))
(OUTENDTAG CONDEXIT)
(COND ((USEDTAGP PAIREXIT)
(CLRSPLD)
(CLEARACS)))
(RESTORE IRSSL)
(RETURN NIL)))
(SETQ PAIR (CAR EXP))
(SETQ RETNIL NIL)
(COND ((NULL (CDR PAIR))
(LOADCOMP (CAR PAIR) AC)
(COND ((NOT (NULL (CDR EXP)))
(OUTCJMP T AC CONDEXIT))
(T (RESTORE IRSSL)))
(GO ELOOP)))
(COND ((AND (EQUAL (CDR PAIR) (Q (NIL)))
(EQ (CAAR PAIR) (QUOTE NULL))
(OR (ATOM (CADAR PAIR))
(NOT (HASPROP (CAADAR PAIR) (Q BOOL)))))
(LOADCOMP (CADAR PAIR) AC)
(OUTCJMP NIL AC CONDEXIT)
(SETQ RETNIL T)
(GO ELOOP)))
(COND ((AND (NOT (ATOM (CADR PAIR)))
(EQ (CAADR PAIR) (QUOTE GO))
(ATOM (CADADR PAIR)))
(COMPPRED (CAR PAIR) AC (EQUIVTAG (CADADR PAIR)) T MINDEPTH)
(GO ELOOP)))
(COND ((EQUAL (CADR PAIR) (Q (RETURN NIL)))
(COMPPRED (CAR PAIR) AC EXITN T MINDEPTH)
(GO ELOOP)))
(SETQ PAIREXIT (GENTAG))
(PUTPROP PAIREXIT IRSSL (QUOTE LEVEL))
(COMPPRED (CAR PAIR) AC PAIREXIT NIL MINDEPTH)
(SETQ ACNIL (EQUAL (SLOTCONT AC) (Q (QUOTE NIL))))
(SETQ H2 (LIST (TOPCOPY ACS) (TOPCOPY PDL)))
(SETQ H1 (TOPCOPY SPLDLST))
(LOADARG (CMPPROGN PAIR VALAC NIL) AC)
(COND ((OR (NOT (NULL (CDR EXP)))
(AND (NOT EFFECTS)
(NOT ACNIL)
(SETQ RETNIL (USEDTAGP PAIREXIT))))
(OUTJRST CONDEXIT))
(T (RESTORE IRSSL)))
(OUTENDTAG PAIREXIT)
(SETQ SPLDLST H1) (SETQ ACS (CAR H2)) (SETQ PDL (CADR H2))
ELOOP(SETQ EXP (CDR EXP))
(GO LOOP)))
(DFUNC (CMPCONS XPR VALAC EFFECTS)
(COND ((NOT (EQ (LENGTH (CDR XPR)) 2)) (BARF ARGNOERR-CMPCONS))
((NULL (CADDR XPR))
(COMPFORM (LIST (Q NCONS) (CADR XPR)) VALAC EFFECTS)))
(T (CALLSUBR XPR VALAC EFFECTS))))
(DFUNC (CMPELSE XPR VALAC EFFECTS)
(PROGN
(SETQ UNDFUNS (CONS (CAR XPR) UNDFUNS))
(PUTPROP (CAR XPR) T (Q *UNDEF))
(CALLSUBR XPR VALAC EFFECTS)))
(DFUNC (CMPEQ XPR VALAC EFFECTS)
(COND (EFFECTS (COMPSTAT (CADR XPR) VALAC)
(COMPSTAT (CADDR XPR) VALAC))
(T (BOOLEQ1 (CDR XPR) VALAC NIL NIL)
(BOOLVALUE XPR VALAC EFFECTS NIL))))
(DFUNC (CMPERRSET XPR VALAC EFFECTS)
(PROG NIL
(COND ((ATOM (CADR XPR))
(RETURN (CALLFSUBR XPR VALAC EFFECTS))))
(RETURN (CALLFSUBR (MCONS (CAR XPR)
(LIST (GENFUN (LIST (Q LAMBDA) NIL (CADR XPR))))
(CDDR XPR))
VALAC
EFFECTS))))
(DFUNC (CMPEVAL XPR VALAC EFFECTS)
(PROG NIL
(COND ((NOT (NULL (CDDR XPR)))
(RETURN (CALLFSUBR XPR VALAC EFFECTS))))
(RETURN (COMPFORM (CONS (Q *EVAL) (CDR XPR)) VALAC EFFECTS))))
(DFUNC (CMPFUNCTION XPR VALAC EFFECTS)
(PROG (FUN)
(SETQ FUN (GENFUN (CADR XPR)))
(COND ((NOT (EQ (CAR XPR) (Q FUNCTION))) (GO *FUN)))
(RETURN (COMPFORM (LIST (Q QUOTE) FUN)) VALAC EFFECTS))
*FUN (CALLFSUBR (LIST (CAR XPR) FUN) VALAC EFFECTS)))
(DFUNC (CMPGO XPR VALAC EFFECTS)
(PROG (TAG)
(SETQ TAG (CADR XPR))
(SAVEACS)
(CLRPVARS)
(COND ((ATOM TAG) (OUTJRST (EQUIVTAG TAG)))
(T (LOADARG (COMPEXPR TAG VALAC) GOTABAC) (OUTJRST VGO)))
(RETURN (VALLOC XPR VALUEAC EFFECTS))))
(DFUNC (CMPLABEL XPR VALAC EFFECTS)
(PROG (FN)
(PUTPROP (CADAR XPR) T (Q FUNVAR))
(SETQ FN (COMPFORM (LIST (Q FUNCTION) (CADDAR XPR))))
(REMPROP (CADAR XPR) (Q FUNVAR))
(RETURN (COMPFORM (LIST (Q PROG)
(LIST (CADAR XPR))
(LIST (Q SETQ) (CADAR XPR) FN)
(LIST (QUOTE RETURN)
(CONS (CADAR XPR) (CDR XPR))))
VALAC EFFECTS))))
(DFUNC (CMPLAM XPR VALAC EFFECTS)
(PROG (LAMXPR LAMARGS SF LAMVARS TL ACL TEM SAVELOCVARS)
(SETQ SAVELOCVARS LOCVARS)
(SETQ LAMXPR (CAR XPR))
(SETQ LAMARGS (REVERSE (COMPARGS (CDR XPR))))
(SETQ LAMVARS (CADR LAMXPR))
A (COND ((NULL LAMVARS) (GO B)))
(SETQ TL (ILOC1 (CAR LAMARGS) (FREEAC)))
(REMOVE (CAR LAMARGS))
(COND ((SPECIALP (CAR LAMVARS))
(SETQ SF T)
(COND ((NOT (ACNUMP TL))
(LOADARG (CAR LAMARGS) (SETQ TL (FREEAC))))))
((OR (NOT (NUMBERP TL))
(DVP (SETQ TEM (SLOTCONT TL))))
(SLOTPUSH TEM)
(COND ((NULL (CDR TEM))
(SETSLOT TL (CONS (CAR TEM) (Q DUP)))))
(OUTPUSH TL)
(SETQ TL 0)))
(SETSLOT TL (CONS (CAR LAMVARS) (QUOTE TAKEN)))
(SETQ ACL (CONS TL ACL))
(SETQ LAMARGS (CDR LAMARGS))
(SETQ LAMVARS (CDR LAMVARS))
(GO A)
B (COND (SF (OUTINST (QUOTE (JSP 6 SPECBIND)))))
(SETQ LAMVARS (CADR LAMXPR))
(SETQ ACL (REVERSE ACL))
C (COND ((NULL LAMVARS) (GO D))
((SPECIALP (CAR LAMVARS))
(CMPLAM1 LAMVARS ACS)
(CMPLAM1 LAMVARS PDL)
(OUTINST (LIST 0
(CAR ACL)
(LIST (Q SPECIAL) (CAR LAMVARS))))))
(REPLACECDR (SLOTCONT (CAR ACL)) NIL)
(SETQ LAMVARS (CDR LAMVARS))
(SETQ ACL (CDR ACL))
(GO C)
D (SETQ TEM (COMPEXPR (CADDR LAMXPR) VALAC))
(COND (SF (OUTINST (QUOTE (PUSHJ P SPECSTR)))))
(SETQ COUNT (ADD1 COUNT))
(UNBINDVARS SAVELOCVARS)
(RETURN TEM)))
(DFUNC (CMPLAM1 X Y) (PROG NIL
A (COND ((NULL Y) (RETURN NIL))
((NULL (CAR Y)))
((AND (EQ (CAAR Y) (CAR X)) (NULL (CDAR Y)))
(REPLACECAR Y NIL)))
(SETQ Y (CDR Y))
(GO A)))
(DFUNC (CMPINMACRO XPR VALAC EFFECTS)
(COMPFORM ((GETPROP (CAR XPR) (Q INMACRO)) XPR) VALAC EFFECTS))
(DFUNC (CMPMACRO XPR VALAC EFFECTS)
(COMPFORM ((GETPROP (CAR XPR) (Q MACRO)) XPR) VALAC EFFECTS))
(DFUNC (CMPPROG XPR VALAC EFFECTS)
(PROG (PSFLG SAVELOCVARS)
(SETQ SAVELOCVARS LOCVARS)
(PUTPROP (Q GO) (Q CMPGO) (Q CMP))
(PUTPROP (Q RETURN) (Q CMPRETURN) (Q CMP))
(SETQ PSFLG (PROGBIND (CADR XPR)))
(SETQ PRGSPFLG NIL)
(CLRSPLD) (SAVEACS) (CLRPVARS)
(CMPPROG1 XPR VALAC EFFECTS MINDEPTH)
(COND (PSFLG (OUTINST (Q (PUSHJ P SPECSTR)))))
(UNBINDVARS SAVELOCVARS)
(RETURN (VALLOC XPR VALAC EFFECTS))))
(DFUNC (CMPPROG1 XPR VALAC EFFECTS MINDEPTH)
(PROG (GOLIST EXIT EXITN PVR PRSSL VGO)
(INCR COUNT)
(SETQ PVR VALAC)
(SETQ EXIT (GENTAG))
(SETQ EXITN (GENTAG))
(SETQ VGO (GENTAG))
(SETQ GOLIST (LIST (CONS NIL EXIT)
(CONS NIL EXITN)
(CONS NIL VGO)))
(COND ((NULL (SETQ PROGVARS (NONSPECVARS (CADR XPR))))
(SETQ PRSSL (TOPCOPY PDL))))
(SETQ XPR (CDDR XPR))
LOOP (COND ((NULL XPR) (GO EXITN)))
(INCR COUNT)
(COND ((TAGP (CAR XPR)) (PROGTAG (CAR XPR)))
((AND (NULL (CDR XPR)) (EQ (CAAR XPR) (QUOTE RETURN)))
(COND ((EQUAL (CDAR XPR) (Q (NIL))) (GO EXITN))
(T (LOADARG (COMPEXPR (CADAR XPR) VALAC) PVR)
(COND ((USEDTAGP EXITN) (OUTJRST EXIT)
(GO EXITN))
(T (GO EXIT))))))
(T (COMPSTAT (CAR XPR) VALAC)))
(SETQ XPR (CDR XPR))
(GO LOOP)
EXITN(OUTENDTAG EXITN)
(COND ((NOT (EQ (CAAR LASTOUT) (QUOTE JRST)))
(LOADARG (Q (QUOTE NIL)) PVR)))
EXIT (OUTENDTAG EXIT)
(SETQ COUNT (PLUS 2 COUNT))
(COND ((USEDTAGP VGO)
(OUTGOTAB (CONS VGO (CDDDR (REVERSE GOLIST))))))
(RETURN NIL)))
(DFUNC (CMPPROG2 XPR VALAC EFFECTS)
(PROG (ARGS ARG2)
(SETQ ARGS (CDR XPR))
(COND ((LESSP (LENGTH ARGS) 2) (BARF TOFEWARGS-CMPPROG2)))
(COMPSTAT (CAR ARGS) VALAC)
(SETQ ARG2 (COMPFORM (CADR ARGS) VALAC EFFECTS))
(SETQ ARGS (CDDR ARGS))
LOOP (COND ((NULL ARGS) (RETURN ARG2)))
(COMPSTAT (CAR ARGS) VALAC)
(SETQ ARGS (CDR ARGS))
(GO LOOP)))
(DFUNC (CMPPROGN XPR VALAC EFFECTS)
(PROG (ARGS)
(COND ((NULL (SETQ ARGS (CDR XPR))) (RETURN NIL)))
LOOP (COND ((NULL (CDR ARGS))
(RETURN (COMPFORM (CAR ARGS) VALAC EFFECTS))))
(COMPSTAT (CAR ARGS) VALAC)
(SETQ ARGS (CDR ARGS))
(GO LOOP)))
(DFUNC (CMPQUOTE XPR VALAC EFFECTS) XPR)
(DFUNC (CMPRETURN XPR VALAC EFFECTS)
(PROG (VAL)
(COND ((NULL (CDR XPR)) (SETQ VAL NIL))
(T (SETQ VAL (CADR XPR))))
(SAVEACS)
(CLRPVARS)
(COND ((NULL VAL) (OUTJRST EXITN))
(T (LOADARG (COMPEXPR VAL VALAC) PVR) (OUTJRST EXIT)))
(RETURN (VALLOC XPR VALAC EFFECTS))))
(DFUNC (CMPRPLAC XPR VALAC EFFECTS)
(PROG (ARG1 ARG2)
(SETQ ARG1 (COMPEXPR (CADR XPR) (FREEAC)))
(SETQ ARG2 (COMPEXPR (CADDR XPR) (FREEAC)))
(ILOC1 ARG1 VALAC)
(LOC ARG2)
(CLRSPLD)
(COND ((EQUAL ARG2 (QUOTE (QUOTE NIL)))
(OUT1 (CADR (ASSOC (CAR XPR)
(Q ((RPLACA HRRZS@) (RPLACD HLLZS@)))))
0
(LOC ARG1)))
(T (OUT1 (CADR (ASSOC (CAR XPR)
(Q ((RPLACA HRLM@) (RPLACD HRRM@)))))
(PUTINAC ARG2 (FREEAC))
(LOC ARG1))))
(REMOVE ARG1)
(REMOVE ARG2)
(RETURN ARG1)))
(DFUNC (CMPSETARG XPR VALAC EFFECTS)
(PROG (TEM)
(LOC (SETQ TEM (COMPEXPR (CADDR XPR) VALAC)))
(COND ((EQ (CAADR XPR) (Q QUOTE))
(OUT1 (Q MOVE) 2 (PDLINDEX))
(RETURN (OUTINST (LIST (Q HRRM)
(PUTINAC TEM VALAC)
(CADADR XPR)
2)))))
(LOADARG (COMPEXPR (CADR XPR)) 2)
(CLEARACS)
(OUT1 (Q ADD) 2 (PDLINDEX))
(OUTINST (LIST (Q HRRM) (PUTINAC TEM VALAC) (MINUS INUM0) 2))))
(DFUNC (CMPSETQ XPR VALAC EFFECTS)
(PROG (VARLOC VALUELOC HOME VAR VAL TEM AC)
(SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
(SETQ VAR (GETVAR (CADR XPR)))
(SETQ VAL (COMPEXPR (CADDR XPR) AC))
(ILOC1 VAL AC)
(COND ((ASSOC VAR SPLDLST) (OUTSPECPUSH VAR) (REMSPVAR VAR)))
(REMOVE VAL)
(FREEZE VAR)
(SETQ VALUELOC (LOC VAL))
(SETQ HOME (COND ((SPECIALP VAR) T)
((NOT (ILOC (SETQ VARLOC (CONS VAR COUNT)) NIL)) NIL)
(T (NOT (DVP (SLOTCONT (LOC VARLOC)))))))
(SETQ COUNT (ADD1 COUNT))
(COND ((AND EFFECTS (NOT HOME))
(COND ((AND (NUMBERP VALUELOC)
(NOT (DVP (SLOTCONT VALUELOC))))
(SETSLOT VALUELOC (LIST VAR))
(GO EXIT))
(T (SLOTPUSH (LIST VAR))
(OUTPUSH VALUELOC)
(GO EXIT)))))
(COND ((AND HOME (EQUAL VAL (QUOTE (QUOTE NIL))))
(SETQ TEM T)
(OUT1 (COND ((OR EFFECTS (DVP (SLOTCONT AC)))
(SETQ TEM NIL)
(QUOTE CLEARM))
(T (QUOTE CLEARB)))
AC
(SETQ VAL (COND ((SPECIALP VAR)
(LIST (QUOTE SPECIAL) VAR))
(T (ILOC (CONS VAR (SUB1 COUNT)) NIL)))))
(COND ((NUMBERP VAL) (SETSLOT VAL (LIST VAR))))
(COND (TEM (SETSLOT AC (CONS VAR
(COND ((NUMBERP VAL) (Q DUP))
(T NIL))))))
(GO EXIT)))
(COND ((OR (NOT (NUMBERP VALUELOC))
(LESSP VALUELOC 0)
(DVP (SLOTCONT VALUELOC)))
(LOADARG VAL AC)
(SETQ VALUELOC AC)))
(SETSLOT VALUELOC (LIST VAR))
(COND ((SPECIALP VAR)
(COND ((ZEROP VALUELOC) (OUTPOP (LIST (QUOTE SPECIAL) VAR)))
(T (OUTMOVEM VALUELOC (LIST (QUOTE SPECIAL) VAR))))))
EXIT (RETURN (COMPFORM VAR AC EFFECTS))))
(DFUNC (CMPSTORE XPR VALAC EFFECTS)
(PROG (TEM)
(LOC (SETQ TEM (COMPEXPR (CADDR XPR) VALAC)))
(COMPSTAT (CADR XPR) VALAC)
(LOADARG TEM ARRAYAC)
(OUTINST (Q (PUSHJ P NSTR)))
(RETURN TEM)))
(DFUNC (COMPEXPR XPR VALAC) (COMPFORM XPR VALAC NIL))
(DFUNC (COMPARGS ARGS)
(PROG (ARGNO RESULT)
(SETQ ARGNO 0)
LOOP (COND ((NULL ARGS) (RETURN RESULT)))
(INCR ARGNO)
(SETQ RESULT (CONS (COMPEXPR (CAR ARGS) ARGNO) RESULT))
(SETQ ARGS (CDR ARGS))
(GO LOOP)))
(DFUNC (COMPFORM XPR VALAC EFFECTS)
(PROG (TEMP)
(COND ((ATOM XPR) (GO ATOM)))
(COND ((ATOM (CAR XPR)) (GO ATOMCAR)))
(COND ((EQ (CAAR XPR) (QUOTE LAMBDA))
(RETURN (CMPLAM XPR VALAC EFFECTS))))
(RETURN (CALLFUNARGS XPR VALAC EFFECTS))
ATOM (COND ((CONSTANTP XPR)
(RETURN (COMPFORM (LIST (Q QUOTE) XPR) VALAC EFFECTS))))
(SETQ TEMP (CONS (SETQ XPR (GETVAR XPR)) (INCR COUNT)))
(COND (EFFECTS (RETURN NIL)))
(COND ((SPECIALP XPR) (SETQ SPLDLST (CONS TEMP SPLDLST))))
(SETQ LDLST (CONS TEMP LDLST))
(RETURN TEMP)
ATOMCAR
(COND ((CONSTANTP (CAR XPR)) (DATAERR CONSTFUN-COMPFORM)))
(COND ((SETQ TEMP (GETGET (CAR XPR) (Q FTYPE)))
(RETURN ((CAR TEMP) XPR VALAC EFFECTS))))
(RETURN (CMPELSE XPR VALAC EFFECTS))))
(DFUNC (COMPSTAT XPR VALAC) (COMPFORM XPR VALAC T))
(DFUNC (CPUSH ACNO)
(PROG (TEMPPDL SLOTNO SLOTCON HOLDSLOT)
(COND ((NOT (DVP (SETQ SLOTCON (SLOTCONT ACNO)))) (RETURN NIL)))
(COND ((LESSP ACNO 1) (BARF ONPDL-CPUSH)))
START(SETQ SLOTNO 0)
(SETQ TEMPPDL PDL)
LOOP (COND ((NULL TEMPPDL) (GO NONE)))
(COND ((DVP (CAR TEMPPDL)) (GO ELOOP)))
(COND ((OR (NOT (NUMBERP (CDAR TEMPPDL)))
(SPECIALP (CAAR TEMPPDL)))
(SETQ HOLDSLOT SLOTNO)))
(COND ((EQ (CAR SLOTCON) (CAAR TEMPPDL)) (GO FOUND)))
ELOOP(SETQ TEMPPDL (CDR TEMPPDL))
(SETQ SLOTNO (SUB1 SLOTNO))
(GO LOOP)
FOUND(SETSLOT SLOTNO SLOTCON)
(SETSLOT ACNO (CONS (CAR SLOTCON) (Q DUP)))
(OUTMOVEM ACNO SLOTNO)
(RETURN NIL)
NONE (COND (HOLDSLOT (SETQ SLOTNO HOLDSLOT) (GO FOUND)))
(SLOTPUSH SLOTCON)
(SETSLOT ACNO (CONS (CAR SLOTCON) (Q DUP)))
(OUTPUSH ACNO)))
(DFUNC (DVP X)
(PROG (LDL)
(COND ((NULL X) (RETURN NIL)))
(COND ((EQ (CAR X) (QUOTE QUOTE)) (RETURN NIL)))
(COND ((EQ (CDR X) (QUOTE DUP)) (RETURN NIL)))
(COND ((EQ (CDR X) (QUOTE TAKEN)) (RETURN T)))
(COND ((AND (SPECIALP (CAR X)) (NULL (CDR X))) (RETURN NIL)))
(COND ((AND (NULL (CDR X)) (ASSOCR (CAR X) LOCVARS)) (RETURN T)))
(SETQ LDL LDLST)
LOOP (COND ((NULL LDL) (RETURN NIL)))
(COND ((AND (EQ (CAAR LDL) (CAR X))
(EQUAL (LOC X) (LOC (CAR LDL))))
(RETURN T)))
(SETQ LDL (CDR LDL))
(GO LOOP)))
(DFUNC (EQUIVTAG PTAG)
(PROG (LTAG)
(COND ((SETQ LTAG (ASSOC PTAG GOLIST)) (RETURN (CDR LTAG))))
(SETQ GOLIST (CONS (CONS PTAG (SETQ LTAG (GENTAG))) GOLIST))
(RETURN LTAG)))
(DFUNC (ERRGO XPR VALAC EFFECTS) (BARF GO NOT INPROG))
(DFUNC (ERRRETURN XPR VALAC EFFECTS) (BARF RETURN NOT IN PROG))
(DFUNC (EXITBUM SPECFLAG)
(PROG (TEM1 TEM2)
(COND ((SETQ TEM1 (ASSOC (CAAR LASTOUT)
(Q ((CALL JCALL) (PUSHJ JRST)))))
(SETQ TEM2 (CAR LASTOUT))
(SETQ LASTOUT NIL)
(KILLPDL)
(OUTINST TEM2)
(COND ((NOT SPECFLAG)
(SETQ TEM2 (CAR LASTOUT))
(SETQ LASTOUT NIL)
(OUTINST (MCONS (CADR TEM1)
(SUBST 0 PDLAC (CADR TEM2))
(CDDR TEM2)))
(RETURN NIL)))))
(KILLPDL)
(COND (SPECFLAG (OUTINST (QUOTE (JRST 0 SPECSTR))))
(T (OUTINST (QUOTE (POPJ P)))))))
(DFUNC (FREEAC) (FREEAC1 NIL))
(DFUNC (FREEAC1 BESTAC) (PROG (ACNO ACCS IT)
(COND ((NULL BESTAC) (SETQ IT NACS))
((NOT (DVP (SLOTCONT BESTAC))) (RETURN BESTAC))
(T (SETQ IT BESTAC)))
(SETQ ACCS ACS)
(SETQ ACNO 0)
LOOP (SETQ ACNO (ADD1 ACNO))
(COND ((NULL ACCS) (CPUSH IT) (RETURN IT)))
(COND ((NULL (CAR ACCS)) (RETURN ACNO)))
(COND ((NOT (DVP (CAR ACCS))) (SETQ IT ACNO)))
(SETQ ACCS (CDR ACCS))
(GO LOOP)))
(DFUNC (FREEZE VAR) (PROGN (FREEZE1 VAR ACS) (FREEZE1 VAR PDL)))
(DFUNC (FREEZE1 X Z)
(PROG NIL
LP (COND ((NULL Z) (RETURN NIL))
((EQ X (CAAR Z))
(COND ((OR (NULL (CDAR Z)) (EQ (CDAR Z) (Q DUP)))
(REPLACECAR Z (CONS X COUNT))))))
(SETQ Z (CDR Z))
(GO LP)))
(DFUNC (GENCONST OP AC AD IN IB)
(PROG (ANS)
(COND ((NOT (ZEROP IB)) (SETQ ANS (LIST *AT))))
(SETQ ANS (APPEND ANS (LIST AC AD IN)))
(SETQ ANS (CONS OP ANS))
(RETURN (CONS (QUOTE C) ANS))))
(DFUNC (GENFUN FUNXPR)
(PROG (NAME LAMLIS CALL)
(COND ((ATOM FUNXPR) (RETURN FUNXPR)))
(COND ((NOT (EQ (CAR FUNXPR) (Q LAMBDA)))
(DATAERR NOTLAMBDA-GENFUN)))
(SETQ LAMLIS (CADR FUNXPR))
(SETQ CALL (CADDR FUNXPR))
(COND ((AND (ATOM (CAR CALL)) (EQUAL LAMLIS (CDR CALL)))
(RETURN (CAR CALL))))
(SETQ NAME (GENFUNNAME))
(SETQ GENFUNS (CONS NAME GENFUNS))
(SETQ SUBFUNS (CONS (LIST (Q DEFPROP) NAME FUNXPR (Q EXPR))
SUBFUNS))
(RETURN NAME)))
(DFUNC (GETSLOT NO)
(COND ((NOT (NUMBERP NO)) (BARF NOTSLOT-GETSLOT))
((GREATERP NO NACS) (PRINTMSG NO) (BARF NOTAC-GETSLOT))
((GREATERP NO 0) (NTHCDR (SUB1 NO) ACS))
((GREATERP (ABS NO) (PDLDEPTH)) (PRINTMSG NO)
(BARF NOTONPDL-GETSLOT))
((NTHCDR (MINUS NO) PDL))))
(DFUNC (GETVAR VAR)
(PROG (TEM)
(COND ((NOT (VARIABLEP VAR)) (BARF NOTVAR-GETVAR)))
(COND ((SETQ TEM (ASSOC VAR LOCVARS)) (RETURN (CDR TEM))))
(COND ((HASPROP VAR (Q SPECIAL)) (RETURN VAR)))
(SETQ UNDECVARS (CONS VAR UNDECVARS))
(MAKESPECIAL VAR)
(RETURN VAR)))
(DFUNC (ILOC X AC)
(PROG (CNTR BEST BESTNO Y SL SLOT CNT XCNT)
(COND ((NULL AC) (GO LOOK)))
(COND ((EQUAL X (SLOTCONT AC)) (RETURN AC)))
LOOK (COND ((EQ (CAR X) (Q QUOTE)) (RETURN (LIST X))))
(SETQ SL (SLOTLIST))
(SETQ CNTR 1)
(SETQ BESTNO (ADD1 COUNT))
(SETQ XCNT (COND ((NUMBERP (CDR X)) (CDR X)) (T COUNT)))
LOOP (COND ((NULL SL) (GO EXIT)))
(SETQ SLOT (CAR SL))
(COND ((AND SLOT (EQ (CAR SLOT) (CAR X))) (GO ISONE)))
ELOOP(SETQ SL (CDR SL))
(SETQ CNTR (ADD1 CNTR))
(GO LOOP)
EXIT (COND ((NOT (GREATERP BESTNO COUNT)) (GO RETN)))
(COND ((SPECIALP (CAR X))
(RETURN (LIST (QUOTE SPECIAL) (CAR X)))))
(RETURN NIL)
ISONE(COND ((EQ (CDR SLOT) (Q TAKEN)) (GO ELOOP)))
(SETQ CNT (COND ((NUMBERP (CDR SLOT)) (CDR SLOT)) (T COUNT)))
(COND ((AND (NOT (LESSP CNT XCNT)) (LESSP CNT BESTNO))
(SETQ BESTNO CNT)
(SETQ BEST CNTR)))
(GO ELOOP)
RETN (RETURN (COND ((NOT (GREATERP BEST NACS)) BEST)
(T (PLUS (MINUS BEST) NACS 1))))))
(DFUNC (ILOC1 X AC)
(PROG (TEM)
(COND ((SETQ TEM (ILOC X AC)) (RETURN TEM)))
(COND ((MEMQ (CAR X) PROGVARS) (RETURN (Q ((QUOTE NIL))))))
(COND ((SETQ TEM (GET (CAR X) (Q CHAIN)))
(RETURN (LOADCARCDR TEM AC))))
(PRINTMSG X)
(BARF LOSTVAR-ILOC1)))
(DFUNC (INITNIL X)
(PROGN (SLOTPUSH (LIST X)) (OUTPUSH (Q ((QUOTE NIL))))))
(DFUNC (KILLPDL) (SHRINKPDL (PDLDEPTH)))
(DFUNC (LAMBDABIND VARS) (BINDVARS VARS T))
(DFUNC (LISTNILS NUMBER) (PROG (LIST)
LOOP (COND ((ZEROP NUMBER) (RETURN LIST)))
(SETQ LIST (CONS NIL LIST))
(SETQ NUMBER (SUB1 NUMBER))
(GO LOOP)))
(DFUNC (LOADARG VAR ACNO)
(PROG (DATAORG OLDACC DATACONT DAC DOD)
(REMOVE VAR)
(SETQ DATAORG (ILOC1 VAR ACNO))
(SETQ OLDACC (SLOTCONT ACNO))
(SETQ DATACONT (COND ((NUMBERP DATAORG) (SLOTCONT DATAORG))))
(SETQ DAC (DVP OLDACC))
(SETQ DOD (DVP DATACONT))
(COND ((EQ ACNO DATAORG) (CPUSH ACNO) (RETURN NIL)))
(COND ((AND (EQ DATAORG 0) (NOT DOD) (NOT DAC) (GREATERP (PDLDEPTH) MINDEPTH)) (GO POP)))
(COND ((AND (NOT DOD) OLDACC (NUMBERP DATAORG) (LESSP DATAORG ACNO))
(GO EXCH)))
(COND ((NOT DAC) (GO FREE)))
(GO PUSH)
EXCH (SETSLOT DATAORG OLDACC)
(SETSLOT ACNO DATACONT)
(OUT1 (QUOTE EXCH) ACNO DATAORG)
(RETURN NIL)
PUSH (CPUSH ACNO)
(SETQ DATAORG (LOC VAR))
FREE (COND ((NOT (NUMBERP DATAORG)) (GO MOVE)))
(SETSLOT ACNO (COND ((NULL (CDR DATACONT))
(CONS (CAR DATACONT) (QUOTE DUP)))
(T DATACONT)))
(OUTMOVE ACNO DATAORG)
(RETURN NIL)
POP (SETSLOT ACNO DATACONT)
(OUTPOP ACNO)
(RETURN NIL)
MOVE (SETSLOT ACNO (COND ((EQ (CAAR DATAORG) (QUOTE QUOTE)) (CAR DATAORG))
(T (LIST (CAR VAR)))))
(OUTMOVE ACNO DATAORG)
(RETURN NIL)))
(DFUNC (LOADCARCDR ITEM AC)
(PROG (ARG PATH ORIG)
(COND ((NULL AC) (SETQ AC (FREEAC))))
(SETQ PATH (GET (CADR ITEM) (Q CARCDR)))
(ILOC1 (SETQ ARG (CDDR ITEM)) AC)
(REMOVE ARG)
(CPUSH AC)
(SETQ ORIG (LOC ARG))
LOOP (COND ((NULL PATH) (GO RET)))
(OUT1 (CAR PATH) AC ORIG)
(SETQ PATH (CDR PATH))
(SETQ ORIG AC)
(GO LOOP)
RET (SETSLOT AC (LIST (CAR ITEM)))
(RETURN AC)))
(DFUNC (LOADCOMP XPR AC) (LOADARG (COMPEXPR XPR AC) AC))
(DFUNC (LOADSUBRARGS ARGS) (PROG (ARGNO)
(SETQ ARGNO (LENGTH ARGS))
LOOP (COND ((NULL ARGS) (RETURN NIL)))
(LOADARG (CAR ARGS) ARGNO)
(SETQ ARGS (CDR ARGS))
(SETQ ARGNO (SUB1 ARGNO))
(GO LOOP)))
(DFUNC (LOC X) (ILOC1 X NIL))
(DFUNC (NONSPECVARS VRS) (PROG (ANS)
LOOP (COND ((NULL VRS) (RETURN ANS))
((SPECIALP (CAR VRS)))
(T (SETQ ANS (CONS (CAR VRS) ANS))))
(SETQ VRS (CDR VRS))
(GO LOOP)))
(DFUNC (OUT1 OP AC AD) (OUTINST (TRANSOUT OP AC AD)))
(DFUNC (OUTCALL NUM FUN) (OUTFUNCALL (Q CALL) NUM FUN))
(DFUNC (OUTCALLF AC AD) (OUT1 (Q CALLF@) AC AD))
(DFUNC (OUTCJMP FLAG AC TAG)
(OUTJMP (COND (FLAG (Q JUMPN)) (T (Q JUMPE))) AC TAG))
(DFUNC (OUTENDTAG X)
(COND ((USEDTAGP X)
(CLEARACS) (RST X) (OUTTAG X))))
(DFUNC (OUTFUNCALL TYPE NUM FUN)
(OUTINST (LIST TYPE NUM (LIST (Q E) FUN))))
(DFUNC (OUTGOTAB X)
(PROG (ETAG)
(SETQ ETAG (GENTAG))
(PUTPROP ETAG (TOPCOPY PDL) (Q LEVEL))
(COND ((NOT (EQ (CAAR LASTOUT) (Q JRST)))
(OUTJRST ETAG)))
(OUTTAG (CAR X))
LOOP (SETQ X (CDR X))
(COND ((NULL X)
(OUTINST (Q (PUSHJ P *UDT)))
(OUTTAG ETAG)
(RETURN NIL)))
(OUTINST (LIST (Q CAIN) GOTABAC (LIST (Q QUOTE) (CAAR X))))
(OUTJRST (CDAR X))
(GO LOOP)))
(DFUNC (OUTJCALL NUM FUN) (OUTFUNCALL (Q JCALL) NUM FUN))
(DFUNC (OUTJMP OP AC ADR) (PROGN
(SAVEACS)
(RST ADR)
(PUTPROP ADR T (QUOTE USED))
(OUTINST (LIST OP AC ADR))))
(DFUNC (OUTJRST ADR) (OUTJMP (Q JRST) 0 ADR))
(DFUNC (OUTMOVE AC MEM) (OUT1 (Q MOVE) AC MEM))
(DFUNC (OUTMOVEM AC MEM) (OUT1 (Q MOVEM) AC MEM))
(DFUNC (OUTPOP L) (PROG2 (SLOTPOP) (OUT1 (QUOTE POP) PDLAC L)))
(DFUNC (OUTPUSH L) (OUT1 (Q PUSH) PDLAC L))
(DFUNC (OUTPUT1 ST)
(PROG (ADD)
(COND ((ATOM ST) (GO PRINT)))
(COND ((EQ (CAR ST) (Q LAP)) (GO PRINT)))
(INCR CODESIZE)
(SETQ ADD (CADDR ST))
(COND ((AND (NOT (ATOM ADD)) (EQ (CAR ADD) (Q C)))
(INCR CONSTSIZE)))
PRINT(PRINTSTAT ST)))
(DFUNC (OUTSPECPUSH VAR)
(PROGN (SLOTPUSH (CONS VAR COUNT)) (OUTPUSH (LIST (QUOTE SPECIAL) VAR))))
(DFUNC (OUTSTAT ST)
(PROG NIL
(COND ((NULL LASTOUT) (GO SETIT)))
(OUTPUT1 (CAR LASTOUT))
(MAPC (FUNCTION PRINTEXPR) (CDR LASTOUT))
SETIT(SETQ LASTOUT (CONS ST (LAPNOTES)))
(RETURN NIL)))
(DFUNC (PROGBIND VARS) (BINDVARS VARS NIL))
(DFUNC (PROGTAG PTAG)
(PROG (LTAG)
(SETQ LTAG (EQUIVTAG PTAG))
(PUTPROP LTAG T (Q DEFINED))
(CLRSPLD)
(CLEARACS)
(CLRPVARS)
(RESTORE PRSSL)
(OUTTAG LTAG)))
(DFUNC (PROTECTACS WHICH) (PUSHACS WHICH T))
(DFUNC (PUSHACS MASK FLAG)
(PROG (ACNO)
(SETQ ACNO 1)
LOOP (COND ((OR (ZEROP MASK) (GREATERP ACNO NACS)) (RETURN NIL)))
(COND ((ZEROP (BOOLE 1 1 MASK)) (GO ELOOP)))
(CPUSH ACNO)
(COND (FLAG (SETSLOT ACNO NIL)))
ELOOP(SETQ MASK (LSH MASK -1))
(SETQ ACNO (ADD1 ACNO))
(GO LOOP)))
(DFUNC (PUTINAC X AC) (PROG (Z)
(SETQ Z (LOC X))
(COND ((NOT (ACNUMP Z)) (LOADARG X (SETQ Z AC))))
(REMOVE X)
(CPUSH Z)
(RETURN Z)))
(DFUNC (REMOVE DATA)
(PROGN (REMLST DATA (Q LDLST)) (REMLST DATA (Q SPLDLST))))
(DFUNC (REMLST DATA LST)
(PROG (TEM)
(SETQ TEM (GETPROP LST (Q VALUE)))
LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
(COND ((EQUAL (CADR TEM) DATA) (REPLACECDR TEM (CDDR TEM)))
(T (SETQ TEM (CDR TEM))))
(GO LOOP)))
(DFUNC (REMSPVAR SPV)
(PROG (SPL)
(SETQ SPL (GETPROP (Q SPLDLST) (Q VALUE)))
BACK (COND ((NULL (CDR SPL)) (RETURN NIL)))
(COND ((EQ SPV (CAADR SPL)) (REPLACECDR SPL (CDDR SPL)))
(T (SETQ SPL (CDR SPL))))
(GO BACK)))
(DFUNC (RESTORE OLDPDL)
(PROG (C V R TEM OLDDEPTH DEPTHDIF)
(SETQ OLDDEPTH (LENGTH OLDPDL))
(COND ((GREATERP OLDDEPTH (PDLDEPTH)) (PRINTMSG (LIST OLDPDL PDL))
(BARF PDLTOOSHORT-RESTORE)))
A1 (SETQ C 0)
A (COND ((EQUAL OLDDEPTH (PDLDEPTH)) (RETURN (SHRINKPDL C)))
((DVP (SETQ R (CAR PDL))) (GO CPP)))
(SETQ C (ADD1 C))
(SLOTPOP)
(GO A)
CPP (SHRINKPDL C)
CPP1 (SETQ V OLDPDL)
(SETQ C 0)
(SETQ DEPTHDIF (*DIF (PDLDEPTH) OLDDEPTH))
CPP3 (COND ((NULL V) (SETSLOT (SETQ V (FREEAC)) R) (OUTPOP V) (GO A1))
((AND (CAR V)
(EQ (CAAR V) (CAR R))
(NOT (DVP (SLOTCONT (SETQ TEM
(MINUS (PLUS C
DEPTHDIF)))))))
(GO CPP2)))
(SETQ C (ADD1 C))
(SETQ V (CDR V))
(GO CPP3)
CPP2 (SETSLOT TEM R)
(OUTPOP TEM)
(GO A1)))
(DFUNC (RST TAG)
(PROG (LEVEL)
(COND ((NULL TAG) (RETURN NIL)))
(COND ((SETQ LEVEL (SEEKPROP TAG (Q LEVEL)))
(RESTORE (PROPVAL LEVEL)))
((REMPROP TAG (QUOTE SET))
(SAVEACS)
(PUTPROP TAG (TOPCOPY PDL) (QUOTE LEVEL))
(SETQ MINDEPTH (PDLDEPTH)))
((ASSOCR TAG GOLIST) (RESTORE PRSSL))
(T (BARF NOLEVEL-RST)))
(RETURN NIL)))
(DFUNC (SAVEACS) (PUSHACS ALLACS NIL))
(DFUNC (SETSLOT X Y) (REPLACECAR (GETSLOT X) Y))
(DFUNC (SHRINKPDL C)
(COND ((NOT (ZEROP C))
(OUTINST (LIST (QUOTE SUB) PDLAC (GENCONST 0 0 C C 0))))))
(DFUNC (SIDEEFFECTS FUN) (NOT (HASPROP FUN (QUOTE ACS))))
(DFUNC (SLOTCONT X) (CAR (GETSLOT X)))
(DFUNC (SLOTLIST) (APPEND ACS PDL))
(DFUNC (SLOTPOP) (SETQ PDL (CDR PDL)))
(DFUNC (SLOTPUSH SC) (SETQ PDL (CONS SC PDL)))
(DFUNC (SPECIALP VAR) (HASPROP VAR (Q SPECIAL)))
(DFUNC (TRANSOUT OP AC AD)
(PROG (TEM IND)
(COND ((OR (ATOM AD) (ATOM (CAR AD))) (GO DONE)))
(SETQ AD (CAR AD))
(COND ((SETQ TEM (SEEKPROP OP (Q IMMED)))
(SETQ OP (PROPVAL TEM))
(GO DONE)))
(SETQ AD (GENCONST 0 0 AD 0 0))
DONE (SETQ IND
(COND ((OR (NOT (NUMBERP AD)) (GREATERP AD 0)) NIL)
(T (LIST PDLAC))))
(RETURN (MCONS OP AC AD IND))))
(DFUNC (UNBINDVARS OLDVARS)
(PROG NIL
(COND ((LESSP (LENGTH LOCVARS) (LENGTH OLDVARS))
(BARF TOOSHORT-UNBINDVARS)))
LOOP (COND ((EQUAL OLDVARS LOCVARS) (RETURN NIL)))
(REMPROP (CDAR LOCVARS) (Q FUNVAR))
(SETQ LOCVARS (CDR LOCVARS))
(GO LOOP)))
(DFUNC (USEDTAGP TAG) (HASPROP TAG (Q USED)))
(DFUNC (VALLOC XPR LOCATION EFFECTS)
(PROG (VAR GVAL)
(COND ((NULL LOCATION) (BARF NULLLOC-VALLOC)))
(COND (EFFECTS (RETURN NIL)))
(SETQ GVAL (GENVAL))
(PUTPROP GVAL XPR (Q ORIGIN))
(SETQ VAR (CAR (SETSLOT LOCATION (LIST GVAL))))
(SETQ LDLST (CONS VAR LDLST))
(RETURN VAR)))
(DFUNC (VARIABLEP EX) (AND (ATOM EX) (NOT (CONSTANTP EX))))
(BEGINBLOCK INTERNALMACROS)
(DEFPROP DEFINMACRO
(LAMBDA (DF) (COMPFUNC (CADR DF) (CADDR DF) (Q *MACRO) (Q INMACRO)))
DEFACTION)
(DEFPROP APPEND
(LAMBDA (L)
(COND ((NULL (CDR L)) NIL)
((NULL (CDDR L)) (CADR L))
(T (LIST (QUOTE *APPEND) (CADR L) (CONS (CAR L) (CDDR L))))))
INMACRO)
(DEFPROP LIST
(LAMBDA (L)
(COND ((NULL (CDR L)) NIL)
((NULL (CDDR L)) (CONS (QUOTE NCONS) (CDR L)))
(T (LIST (QUOTE CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
INMACRO)
(DEFPROP NOT (LAMBDA (L) (LIST (QUOTE NULL) (CADR L))) INMACRO)
(ENDBLOCK INTERNALMACROS)
(MAPDEF FTYPE
((EXPR CALLSUBR) (SUBR CALLSUBR)
(*SUBR CALLSUBR)
(*UNDEF CALLSUBR)
(LSUBR CALLLSUBR)
(*LSUBR CALLLSUBR)
(FEXPR CALLFSUBR)
(FSUBR CALLFSUBR)
(*FSUBR CALLFSUBR)
(FUNVAR CALLFUNARGS)
(SPECIAL CALLFUNARGS)
(CARCDR CMPCARCDR)
(COMMU CALLCOMMU)
(MACRO CMPMACRO)
(INMACRO CMPINMACRO)
(CMP CALLCMP)))
(MAPDEF CMP
((AND CMPBOOL) (ARG CMPARG)
(*EVAL CMP*EVAL)
(COND CMPCOND)
(CONS CMPCONS)
(EQ CMPEQ)
(ERRSET CMPERRSET)
(EVAL CMPEVAL)
(FUNCTION CMPFUNCTION)
(*FUNCTION CMPFUNCTION)
(GO CMPGO)
(NULL CMPBOOL)
(OR CMPBOOL)
(QUOTE CMPQUOTE)
(PROG CMPPROG)
(PROG2 CMPPROG2)
(RETURN CMPRETURN)
(RPLACA CMPRPLAC)
(RPLACD CMPRPLAC)
(SETARG CMPSETARG)
(SETQ CMPSETQ)
(STORE CMPSTORE)))
(MAPDEF BOOL
((AND BOOLAND) (EQ BOOLEQ)
(NULL BOOLNULL)
(OR BOOLOR)
(QUOTE BOOLQUOTE)))
(SETQ CARCDRDEPTH 4)
(PROG (BASE COUNT LIMIT FORM NAME)
(SETQ BASE 2)
(SETQ LIMIT (SUB1 (LSH 1 (ADD1 CARCDRDEPTH))))
(SETQ COUNT (LSH 1 1))
LOOP (COND ((GREATERP COUNT LIMIT) (RETURN NIL)))
(SETQ FORM (CDR (EXPLODE COUNT)))
(SETQ NAME (READLIST (APPEND (QUOTE (C))
(SUBST (QUOTE A) 0 (SUBST (QUOTE D) 1 FORM))
(QUOTE (R)))))
(PUTPROP NAME
(SUBST (QUOTE HLRZ@) 0 (SUBST (QUOTE HRRZ@) 1 (REVERSE FORM)))
(QUOTE CARCDR))
(SETQ COUNT (ADD1 COUNT))
(GO LOOP))
(MAPDEF ACS
((*APPEND 37)
(ATOM 1)
(CONS 3)
(GENSYM 7)
(GET 3)
(LAST 3)
(LENGTH 7)
(MEMBER 37)
(NCONS 3)
(XCONS 3)))
(MAPDEF COMMU
((CONS XCONS) (EQUAL EQUAL)
(*GREAT *LESS)
(*LESS *GREAT)
(*PLUS *PLUS)
(*TIMES *TIMES)))
(MAPDEF IMMED
((CAME CAIE) (CAMN CAIN)
(HLLZS@ HLLZS)
(HLRZ@ HLRZ)
(HRLM@ HRLM)
(HRRM@ HRRM)
(HRRZ@ HRRZ)
(HRRZS@ HRRZS)
(MOVE MOVEI)))
(SETQ NACS 5)
(SETQ VALUEAC 1)
(SETQ FARGAC 1)
(SETQ GOTABAC 1)
(SETQ ARRAYAC 1)
(SETQ PDLAC (QUOTE P))
(SETQ INUM0 (MAKNUM 0 (QUOTE FIXNUM)))
(ENDBLOCK COMPILE)
(BEGINBLOCK DEBUG)
(DEFPROP BARF (LAMBDA (L) (COMPBREAK (Q (*COMPILER ERROR*)) L)) FEXPR)
(DEFPROP DATAERR (LAMBDA (L) (COMPBREAK (Q (*USER ERROR*)) L)) FEXPR)
(DFUNC (COMPBREAK TYPE MESSAGE)
(PROG NIL
(INC NIL T)
(OUTC NIL T)
(CARRET)
(LINEF)
(PRINL (APPEND TYPE MESSAGE))
LOOP (COND ((EQUAL (ERRSET (EVALREAD)) (Q (PROCEED)))
(RETURN (Q DONE))))
(GO LOOP)))
(DFUNC (EVALREAD) (PROG (EX)
(CARRET)
(SETQ EX (READ))
(PRINC *SP)
(RETURN (PRINC (EVAL EX)))))
(DFUNC (LAPNOTES) (COPY (MAPCAR (FUNCTION EVAL) TRACELIST)))
(SETQ SHOWNAMES T)
(SETQ TRACELIST NIL)
(ENDBLOCK DEBUG)
(BEGINBLOCK IO)
(DFUNC (CARRET) (COND ((NOT (EQ (CHRCT) (LINELENGTH NIL))) (LINEF))))
(DFUNC (DEVP L) (OR (AND (ATOM L) (EQ (CAR (LAST L)) *COLON))
(AND (NOT (ATOM L)) (NOT (ATOM (CDR L))))))
(DFUNC (LINEF) (PROG (LINEL)
(SETQ LINCNT (SUB1 LINCNT))
(SETQ LINEL (LINELENGTH NIL))
(LINELENGTH 1)
(PRINC *SP)
(LINELENGTH LINEL)
(TERPRI)))
(DFUNC (PRINL L) (MAPC (FUNCTION PRINS) L))
(DFUNC (PRINS X) (PROG2 (PRIN1 X) (PRINC *SP)))
(DFUNC (PRINTEXPR XPR) (PROG2 (PRIN1 XPR) (PRINC *SP)))
(DFUNC (PRINTLAP CODE) (MAPC (FUNCTION PRINTSTAT) CODE))
(DFUNC (PRINTSTAT STAT)
(PROG NIL
(COND ((GREATERP (DIFFERENCE (LINELENGTH NIL) (CHRCT)) 7) (LINEF)))
(COND ((NULL STAT) (GO WORD))
((ATOM STAT) (GO TAG))
((EQ (CAR STAT) (QUOTE LAP)) (GO TAG)))
WORD (PRINC *TB)
(PRINTEXPR STAT)
(RETURN NIL)
TAG (CARRET)
(PRINTEXPR STAT)
(RETURN NIL)))
(DFUNC (READLAP CALL)
(PROG (STAT CODE)
(SETQ CODE (LIST CALL))
READ (SETQ STAT (ERRSET (READ)))
(COND ((ATOM STAT) (BARF READERR-READLAP)))
(SETQ CODE (CONS (CAR STAT) CODE))
(COND ((NULL (CAR STAT)) (RETURN (REVERSE CODE))))
(GO READ)))
(MAPCAR
(FUNCTION
(LAMBDA (PAIR) (PROG2 (SET (CAR PAIR) (INTERN (ASCII (CADR PAIR))))
(CAR PAIR))))
(QUOTE ((*SP 40) (*TB 11)
(*CR 15)
(*LF 12)
(*VT 13)
(*FF 14)
(*CO 54)
(*PT 56)
(*LP 50)
(*RP 51)
(*SL 57)
(*AM 33)
(*AT 100)
(*RO 177)
(*COLON 72))))
(SETQ LINCNT 0)
(SETQ PAGEHEIGHT 74)
(SETQ PAGEWIDTH 120)
(ENDBLOCK IO)
(BEGINBLOCK GENERAL)
(DFUNC (ASSOCR X Y)
(PROG NIL
LOOP (COND ((NULL Y) (RETURN NIL)) ((EQ X (CDAR Y)) (RETURN (CAR Y))))
(SETQ Y (CDR Y))
(GO LOOP)))
(DFUNC (CONSTANTP XPR) (OR (NUMBERP XPR) (MEMQ XPR (QUOTE (T NIL)))))
(DFUNC (COPY EX) (SUBST 0 0 EX))
(DFUNC (GETGET ATOM PROP)
(PROG (TEM PTAB)
(SETQ PTAB (PROPTABLE ATOM))
LOOP (COND ((NULL PTAB) (RETURN NIL)))
(COND ((SETQ TEM (GETL (CAR PTAB) (LIST PROP)))
(RETURN (LIST (CADR TEM)))))
(SETQ PTAB (CDDR PTAB))
(GO LOOP)))
(DFUNC (INITSYM NAME) (PUTPROP NAME 0 (Q SYMNO)))
(DFUNC (MAKESPECIAL VAR) (PUTPROP VAR T (Q SPECIAL)))
(DFUNC (MAKESYM IDENT NUMBER)
(PROG (*NOPOINT)
(SETQ *NOPOINT T)
(RETURN (MAKNAM (APPEND (EXPLODE IDENT) (EXPLODE NUMBER))))))
(DFUNC (MAKEUNSPECIAL VAR) (REMPROP VAR (Q SPECIAL)))
(DFUNC (NEXTSYM NAME)
(PROG (NUM)
(SETQ NUM (GETPROP NAME (Q SYMNO)))
(PUTPROP NAME (ADD1 NUM) (Q SYMNO))
(RETURN (MAKESYM NAME NUM))))
(DFUNC (NTHCDR NUM EXP)
(PROG NIL
(COND ((MINUSP NUM) (BARF NEGNUM-NTHCDR)))
LOOP (COND ((ZEROP NUM) (RETURN EXP)))
(COND ((ATOM EXP) (BARF ATOM-NTHCDR)))
(SETQ EXP (CDR EXP))
(SETQ NUM (SUB1 NUM))
(GO LOOP)))
(DEFPROP PROGN (LAMBDA L (ARG L)) EXPR)
(DFUNC (TOPCOPY SXP) (APPEND SXP NIL))
(BEGINBLOCK PROPTABLE)
(DFUNC (INITPROP IDENT PROPNAM PROPVAL)
(PUTPROP IDENT PROPVAL PROPNAM))
(DFUNC (SEEKPROP IDENT PROPNAM)
(PROG (TEM)
(SETQ TEM (GETL IDENT (LIST PROPNAM)))
(COND ((NULL TEM) (RETURN NIL)))
(RETURN (CDR TEM))))
(DFUNC (SETPROP IDENT PROPNAM PROPVAL)
(PUTPROP IDENT PROPVAL PROPNAM))
(DFUNC (HASPROP IDENT PROP) (GETL IDENT (LIST PROP)))
(ENDBLOCK PROPTABLE)
(ENDBLOCK GENERAL)
(ENDBLOCK COMPILER)